perm filename FLIP[1,LMM] blob
sn#021329 filedate 1973-01-24 generic text, type T, neo UTF8
(PROGN (LISPXPRIN1 (QUOTE "FILE CREATED ")
T)
(LISPXPRIN1 (QUOTE "24-JAN-73 05:15:43")
T)
(LISPXTERPRI T))
(LISPXPRINT (QUOTE FLIPVARS)
T)
(RPAQQ FLIPVARS
((FNS MAKECOND GENSYML FIXSELM SELECTM PARSE1 MAKETST SOMETAIL
ELTPAT PARSE SINGLEPATLIST MAKENLEFT MAKENLISTP TSTMATCH
MAKEEQLENGTH ISDOLLARSAM MAKEPROG EASYTORECOMPUTE
MAKETSTLENGTH ISDOLLARN SINGLEPAT MAKEDEFAULT MAKESUBST1
MAKESUBST EQTOMEMB !MAKEAND MAKESOME MAKEOR MAKELISTP MM
MAKESETQ MAKEPROGN MAKEEQUAL MAKECDR MAKECAR MAKEAND
MAKEMATCH PRINSET MATCH MAKEREPLACE FIXSELM FOO PACKSYM)
(VARS SETFNS VARDEFAULT LISTPCHK (GENSYMCNT 0))
(PROP MACRO :)))
(DEFINEQ
(MAKECOND
[LAMBDA (PRED RESLT)
(LIST (QUOTE COND)
(CONS PRED RESLT])
(GENSYML
[LAMBDA (VAR)
(COND
((LISTP VAR)
(GENSYML (CADR VAR)))
[(GETP VAR (QUOTE GENSYM))
(PACKSYM (GETP VAR (QUOTE GENSYM]
(T ([LAMBDA (NEW)
(PUT NEW (QUOTE GENSYM)
VAR)
NEW]
(PACKSYM VAR])
(FIXSELM
[LAMBDA (SELLIST)
(COND
((NULL (CDR SELLIST))
(LIST (CONS (QUOTE T)
SELLIST)))
(T (CONS (CONS (MAKEMATCH SELEXP (PARSE (CAAR SELLIST)))
(CDAR SELLIST))
(FIXSELM (CDR SELLIST])
(SELECTM
[NLAMBDA SELM
(COND
((EQ (CAADR SELM)
(QUOTE *))
(EVAL (CADADR SELM)))
(T
(PROG ((SELEXP (CAR SELM))
FIXEDSELM)
[SETQ FIXEDSELM
(CONS (QUOTE COND)
(COND
((EASYTORECOMPUTE SELEXP)
(FIXSELM (CDR SELM)))
(T (MAKEPROG
(LIST (LIST (QUOTE SELVAL)
SELEXP))
(PROG ((SELEXP (QUOTE SELVAL))
(LIST (FIXSELM (CDR SELM]
(/ATTACH (LIST (QUOTE *)
FIXEDSELM)
SELM)
(RETURN (EVAL FIXEDSELM])
(PARSE1
[LAMBDA (PAT BACKPAT)
[SETQ PAT
(COND
((NULL PAT)
NIL)
((NLISTP PAT)
(PARSE1 (LIST (QUOTE !)
PAT)))
[(NLISTP (CAR PAT))
(SELECTQ
(CAR PAT)
[(' = ==)
(PARSE1 (CDDR PAT)
(LIST (CAR PAT)
(CADR PAT]
((& -- $1 $ ≠ ≠1 *)
(PARSE1 (CDR PAT)
(CAR PAT)))
[! (COND
[(EQ (CADR PAT)
(QUOTE ←))
(PARSE1 (CONS (QUOTE $)
(CDR PAT]
(T (PROG [(X (PARSE1 (CDR PAT]
(PATCONS (CONS (CAR PAT)
(CAR X))
(CDR X]
(# (HELP "CANT PARSE" PAT))
[←(COND
((EQ (CAR BACKPAT)
(QUOTE DEFAULT))
(SETQ PAT (PARSE1 (CDR PAT)))
(PROG1 (CONS (LIST (QUOTE ←)
BACKPAT
(CAR PAT))
(CDR PAT))
(SETQ BACKPAT NIL)))
(T (PROG1 (CONS (LIST (QUOTE ←)
BACKPAT
(LIST (QUOTE DEFAULT)
(CADR PAT)))
(PARSE1 (CDDR PAT)))
(SETQ BACKPAT NIL]
(COND
[(EQ (NTHCHAR (CAR PAT)
-1)
(QUOTE ≠))
(PARSE1
(CDR PAT)
(LIST (QUOTE PRED)
(CONS (QUOTE STRPOS)
(CONS (MKSTRING (CAR PAT))
(CONS (QUOTE *)
(QUOTE (1 NIL T]
(T (PARSE1 (CDR PAT)
(LIST (QUOTE DEFAULT)
(CAR PAT]
(T (SELECTQ (CAAR PAT)
[(←
ANY)
(PARSE1 (CDR PAT)
(CONS (CAAR PAT)
(PARSE1 (CDAR PAT]
(PARSE1 (CDR PAT)
(PARSE1 (CAR PAT]
(COND
(BACKPAT (CONS BACKPAT PAT))
(T PAT])
(MAKETST
[LAMBDA (TYPE SAMEAS VAR)
(SELECTQ TYPE
(=(MAKEEQUAL VAR SAMEAS))
('(MAKEEQUAL VAR (KWOTE SAMEAS)))
(==(LIST (QUOTE EQ)
VAR SAMEAS))
(PRED (MAKESUBST (QUOTE (*OR* & $1 ≠1 *))
VAR SAMEAS))
(HELP])
(SOMETAIL
[LAMBDA (L PRED)
(SOME L (FUNCTION (LAMBDA (X Y)
(APPLY* PRED Y])
(ELTPAT
[LAMBDA (PAT)
(COND
[(NLISTP PAT)
(* Check for $i, where i is a small number -
Should be handled in PARSE)
(NOT (OR [AND (EQ (NTHCHAR PAT 1)
(QUOTE $))
([LAMBDA (X)
(AND (NUMBERP X)
(OR (IGREATERP X 1)
(ILESSP X 0]
(PACK (CDR (UNPACK PAT]
(MEMB PAT (QUOTE (-- ≠ $]
((EQ (CAR PAT)
(QUOTE ANY))
(EVERY (CDR PAT)
(FUNCTION ELTPAT)))
[(MEMB (CAR PAT)
(QUOTE (←
SETQ SET)))
(AND (ELTPAT (CADR PAT))
(ELTPAT (CADDR PAT]
[(MEMB (CAR PAT)
(QUOTE (= ' ==]
((MEMB (CAR PAT)
(QUOTE (!)))
NIL)
(T
(* Every other case is ok --
(default var) or (SUB pattern))
T])
(PARSE
[LAMBDA (PAT)
(* The thing is that PARSE1 will COLLECT numbers one
of these days -- NUMLIST will be the numbers
collected -- the numbers are hard when explicitly
given -- impossible when given as an expression)
(PROG (NUMLIST)
(SETQ PAT (PARSE1 PAT))
(RETURN PAT])
(SINGLEPATLIST
[LAMBDA (PAT)
(EVERY PAT (FUNCTION (LAMBDA (X)
(ELTPAT X])
(MAKENLEFT
[LAMBDA (VAR N)
(SELECTQ N
(1 (LIST (QUOTE LAST)
VAR))
(LIST (QUOTE NLEFT)
VAR N])
(MAKENLISTP
[LAMBDA (FORM)
(LIST (QUOTE NLISTP)
FORM])
(TSTMATCH
[NLAMBDA PATTERN
(PROG (RESULT)
LP [PRINTDEF (MAKEMATCH
(QUOTE X)
(PRINT (PARSE (OR PATTERN (PROGN (PRIN1
"
PATTERN? " T)
(READ T]
(OR PATTERN (GO LP))
(RETURN (TERPRI])
(MAKEEQLENGTH
[LAMBDA (VAR N)
(SELECTQ N
(0 (LIST (QUOTE NOT)
VAR))
[1 (MAKEAND (MAKELISTP VAR)
(MAKENLISTP (MAKECDR VAR]
(LIST (QUOTE EQ)
(LIST (QUOTE LENGTH)
VAR)
N])
(ISDOLLARSAM
[LAMBDA (PAT VAR)
(PROG (PAT2)
(RETURN (COND
([EVERY PAT (FUNCTION (LAMBDA (PAT3 PAT4)
(SETQ PAT2 PAT4)
(MEMB PAT3 (QUOTE ($1 ≠1 &]
(MAKEEQLENGTH VAR (LENGTH PAT)))
([MEMBER PAT2 (QUOTE ((--)
($)
(≠]
(MAKETSTLENGTH VAR (SUB1 (LENGTH PAT])
(MAKEPROG
[LAMBDA (VARS BODY)
(COND
[(AND (EQ (CAAR BODY)
(QUOTE PROG))
(NOT (CDR BODY)))
(CONS (QUOTE PROG)
(CONS (APPEND VARS (CADAR BODY))
(CDAR BODY]
(T (CONS (QUOTE PROG)
(CONS VARS BODY])
(EASYTORECOMPUTE
[LAMBDA (EXP)
(OR (NLISTP EXP)
(AND (GETP (CAR EXP)
(QUOTE CROPS))
(EASYTORECOMPUTE (CADR EXP])
(MAKETSTLENGTH
[LAMBDA (VAR N)
(SELECTQ N
(1 (MAKELISTP VAR))
(LIST (QUOTE IGREATERP)
(LIST (QUOTE LENGTH)
VAR)
(SUB1 N])
(ISDOLLARN
[LAMBDA (PAT VAR)
(AND [EVERY PAT (FUNCTION (LAMBDA (PAT1)
(MEMB PAT1 (QUOTE ($1 ≠1 &]
(MAKETSTLENGTH VAR (LENGTH PAT])
(SINGLEPAT
[LAMBDA (PAT)
(AND (NULL (CDR PAT))
(ELTPAT (CAR PAT])
(MAKEDEFAULT
[LAMBDA (PAT)
(SELECTQ VARDEFAULT
((←
SETQ SET)
(LIST (QUOTE ←)
PAT
(QUOTE $1)))
((QUOTE ')
(LIST (QUOTE ')
PAT))
((= EQUAL)
(LIST (QUOTE =)
PAT))
(HELP "FUNNY VARDEFAULT"])
(MAKESUBST1
[LAMBDA (EXPR)
(COND
((NLISTP EXPR)
EXPR)
([OR (EQUAL (CAR EXPR)
OLD)
(AND (EQ (CAR OLD)
(QUOTE *ANY*))
(MEMBER (CAR EXPR)
(CDR OLD]
(COND
((NOT FOUNDBEFORE)
(SETQ FOUNDBEFORE EXPR))
((EQ FOUNDBEFORE T))
(T (RPLACA FOUNDBEFORE (SETQ NEW (GENSYML OLD)))
(SETQ FOUNDBEFORE T)))
(RPLACA EXPR NEW)
(MAKESUBST1 (CDR EXPR)))
(T (MAKESUBST1 (CAR EXPR))
(MAKESUBST1 (CDR EXPR))
EXPR])
(MAKESUBST
[LAMBDA (OLD NEW EXPR)
(COND
((EASYTORECOMPUTE NEW)
(OR [CAR (NLSETQ (ESUBST NEW OLD (COPY EXPR]
(HELP " BAD SUBSTITUTION ")))
(T (PROG ((SAVNEW NEW)
FORM FOUNDBEFORE)
[SETQ FORM (MAKESUBST1 (SETQ EXPR (COPY EXPR]
(COND
((EQ FOUNDBEFORE T)
(LIST (QUOTE PROG)
(LIST (LIST NEW SAVNEW))
(LIST (QUOTE RETURN)
EXPR)))
(T EXPR])
(EQTOMEMB
[LAMBDA (X)
(SELECTQ X
(EQ (QUOTE MEMB))
(EQUAL (QUOTE MEMBER))
(HELP "BAD EQ≠"])
(!MAKEAND
[LAMBDA (LFORMS)
(COND
((NULL (CDR LFORMS))
(CAR LFORMS))
(T (MAKEAND (CAR LFORMS)
(!MAKEAND (CDR LFORMS])
(MAKESOME
[LAMBDA (VAR VAR2 FORM) (* Want (sometail VAR
(f/l (VAR2) FORM)) or
it's equivalent)
(COND
((AND (MEMB (CAR FORM)
(QUOTE (EQ EQUAL)))
(EQ (CAADR FORM)
(QUOTE CAR))
(EQ (CADADR FORM)
VAR2))
(* (sometail X (EQ (CAR X1) &)) is the same as MEMB)
(LIST (EQTOMEMB (CAR FORM))
(CADDR FORM)
VAR))
[(AND (EQ (CAR FORM)
(QUOTE AND))
(MEMB (CAADR FORM)
(QUOTE (EQ EQUAL)))
(EQ (CAR (CADADR FORM))
(QUOTE CAR))
(EQ (CADR (CADADR FORM))
VAR2))
(* (sometail VAR (AND (EQ (CAR VAR2) &) FORM)) is
the same as FORM with MEMB in place of VAR2 inside
FORM -- MAKESUBST checks for two occurances of the
MEMB, and sets a VAR instead)
(MAKESUBST VAR2 (LIST (EQTOMEMB (CAADR FORM))
(CADDR (CADR FORM))
VAR)
(!MAKEAND (CDDR FORM]
(T (* Otherwise ,
explicitly call
sometail)
(LIST (QUOTE SOMETAIL)
VAR
(LIST (QUOTE FUNCTION)
(LIST (QUOTE LAMBDA)
(LIST VAR2)
FORM])
(MAKEOR
[LAMBDA (L)
(CONS (QUOTE OR)
L])
(MAKELISTP
[LAMBDA (VAR)
(LIST (QUOTE LISTP)
VAR])
(MM
[NLAMBDA FORM
(MAKEMATCH (QUOTE X)
FORM LISTPCHK])
(MAKESETQ
[LAMBDA (VAR VAL)
(LIST (QUOTE SETQ)
VAR VAL])
(MAKEPROGN
[LAMBDA (FORM1 FORM2)
(COND
[(EQ (CAR FORM2)
(QUOTE PROGN))
(CONS (QUOTE PROGN)
(CONS FORM1 (CDR FORM2]
((EQ T FORM2)
FORM1)
((EQ T FORM1)
FORM2)
(T (LIST (QUOTE PROGN)
FORM1 FORM2])
(MAKEEQUAL
[LAMBDA (TST1 TST2)
(LIST (COND
([OR (AND (EQ (CAR TST1)
(QUOTE QUOTE))
(ATOM (CADR TST1)))
(AND (EQ (CAR TST2)
(QUOTE QUOTE))
(ATOM (CADR TST2]
(QUOTE EQ))
(T (QUOTE EQUAL)))
TST1 TST2])
(MAKECDR
[LAMBDA (FORM)
(SELECTQ (CAR FORM)
(CAR (LIST (QUOTE CDAR)
(CADR FORM)))
(CDR (LIST (QUOTE CDDR)
(CADR FORM)))
(CAAR (LIST (QUOTE CDAAR)
(CADR FORM)))
(CADR (LIST (QUOTE CDADR)
(CADR FORM)))
(CDAR (LIST (QUOTE CDDAR)
(CADR FORM)))
(CDDR (LIST (QUOTE CDDDR)
(CADR FORM)))
(LIST (QUOTE CDR)
FORM])
(MAKECAR
[LAMBDA (FORM)
(SELECTQ (CAR FORM)
(CAR (LIST (QUOTE CAAR)
(CADR FORM)))
(CDR (LIST (QUOTE CADR)
(CADR FORM)))
(CAAR (LIST (QUOTE CAAAR)
(CADR FORM)))
(CADR (LIST (QUOTE CAADR)
(CADR FORM)))
(CDAR (LIST (QUOTE CADAR)
(CADR FORM)))
(CDDR (LIST (QUOTE CADDR)
(CADR FORM)))
(LIST (QUOTE CAR)
FORM])
(MAKEAND
[LAMBDA (FORM1 FORM2)
(COND
((EQ FORM2 T)
FORM1)
((EQ FORM1 T)
FORM2)
[(EQ (CAR FORM2)
(QUOTE AND))
(CONS (QUOTE AND)
(CONS FORM1 (CDR FORM2]
[(EQ (CAR FORM1)
(QUOTE AND))
(CONS (QUOTE AND)
(APPEND (CDR FORM1)
(LIST FORM2]
((EQ (CAR FORM1)
(QUOTE SETQ))
(MAKEPROGN FORM1 FORM2))
(T (LIST (QUOTE AND)
FORM1 FORM2])
(MAKEMATCH
[LAMBDA (VAR PAT LISTPCHK VALUETYPE)
(* Constructs an expression which will match PAT
against VAR -
LISTPCHK is set to either NIL , T, or NEVER;
or a list of those items -
If it is NIL, dont check LISTP unless context
couldn't mean anything else -
If it is T, always check LISTP -
If it is NEVER, dont check even if the context
couldn't mean anything else)
(* VALUETYPE tells what kind of VALUE the expression
is supposed to return -
If it is match? then the expression must be NIL if
NO MATCH and non-nil if MATCH;
if it is NIL, then the expression can return
anything, but preferably then *'d expression if
possible, or else then the last SETQ, or else the
last MATCH)
(PROG ((MATCH (EQ VALUETYPE (QUOTE MATCH?)))
NEVER YES NO TMP TMP1)
(SELECTQ [COND
((ATOM LISTPCHK)
LISTPCHK)
(T (PROG1 (CAR LISTPCHK)
(SETQ LISTPCHK (CDR LISTPCHK]
((NIL NO)
(SETQ NO T))
((T YES)
(SETQ YES T))
(SETQ NEVER T))
LP (RETURN
(COND
((NOT PAT)
(* If we have CDR ed down to NIL, then there is
nothing else to check (unless LISTPCHK is YES))
(COND
(YES (LIST 'NOT VAR))
(T)))
([MEMBER PAT (QUOTE (($)
(--)
(≠]
(* In any case, if a pattern ends in $, everything
is ok, even if LISTPCHK is on)
T)
((NLISTP PAT)
(* This is for the case where one has
(... . Y) where Y is something to be default'ed -
Need to work out about (... . $1))
(COND
((MEMB PAT
(QUOTE ($ $1 ≠ -- ! ←
%. * = ==)))
(HELP "P.P.E. IN PATTERN" PAT)))
(* Depending on VARDEFAULT, an atom without ' = or a
SETQ is handled in different ways)
(HELP "DEFAULT SHOULD BE HANDLED IN PARSE")
(MAKEDEFAULT PAT VAR))
((AND (NOT NEVER)
(ISDOLLARSAM PAT VAR)))
[(ELTPAT (CAR PAT)) (* We want a LISTPCHK
here, for a pattern that
is not NIL)
([LAMBDA (TST)
(COND
(YES (MAKEAND (MAKELISTP VAR)
TST))
(T TST]
(COND
((MEMB (CAR PAT)
(QUOTE (≠1 $1 &)))
(* LISTPCHK has been
taken care of, so just
CDR down)
(MAKEMATCH (MAKECDR VAR)
(CDR PAT)
LISTPCHK VALUETYPE))
((EQ (CAR PAT)
(QUOTE *))
(MAKEAND (MAKEMATCH (MAKECDR VAR)
(CDR PAT)
LISTPCHK VALUETYPE)
(MAKECAR VAR)))
((MEMB (CAAR PAT)
(QUOTE (= == ' PRED)))
(* (... == VAR ...) -> (AND
(EQ (CAR X) VAR) ...))
(MAKEAND (MAKETST (CAAR PAT)
(CADAR PAT)
(MAKECAR VAR))
(MAKEMATCH (MAKECDR VAR)
(CDR PAT)
LISTPCHK VALUETYPE)))
((EQ (CAAR PAT)
(QUOTE DEFAULT)) (* This really should be
handled in PARSE)
(MAKEMATCH VAR (CONS (MAKEDEFAULT (CADAR PAT))
(CDR PAT))
LISTPCHK VALUETYPE))
((NLISTP (CAR PAT))
(* Otherwise, the PAT has (-- VAR --) and we do the
default thing with VAR and then just CDR)
(HELP "DEFAULT SHOULD BE HANDLED IN PARSE"))
[(EQ (CAAR PAT)
(QUOTE ←))
(* The ← is easier when there is only a single
pattern -
What is to be set is always CAR VAR)
(COND
[(EQ (CAADAR PAT)
(QUOTE DEFAULT)) (* This is the FOO ← &
case)
(SELECTQ (CADDAR PAT)
((& ≠ $1)
(MAKEPROGN
(MAKESETQ (CADR (CADAR PAT))
(MAKECAR VAR))
(MAKEMATCH (MAKECDR VAR)
(CDR PAT)
LISTPCHK VALUETYPE)))
([LAMBDA (X Y)
(COND
(MATCH (MAKECOND X
(LIST Y T)))
(T (MAKEAND X Y]
(MAKEMATCH VAR
(CONS (CADDAR PAT)
(CDR PAT))
(CONS (QUOTE NEVER)
LISTPCHK)
VALUETYPE)
(MAKESETQ
(CADR (CADR (CAR PAT)))
(MAKECAR VAR]
(T (* This is the & ← FOO
case)
(SELECTQ
(CADAR PAT)
[(& ≠ $1)
(MAKEAND (MAKEMATCH (MAKECDR VAR)
(CDR PAT)
LISTPCHK VALUETYPE)
(MAKEREPLACE
(MAKECAR VAR)
(CADR (CADDAR PAT]
(MAKEAND (MAKEMATCH VAR
(CONS (CADAR PAT)
(CDR PAT))
(CONS (QUOTE NEVER)
LISTPCHK)
VALUETYPE)
(MAKEREPLACE (MAKECAR VAR)
(CADR (CADDAR PAT]
(T (MAKEAND (MAKEMATCH (MAKECAR VAR)
(CAR PAT)
LISTPCHK VALUETYPE)
(MAKEMATCH (MAKECDR VAR)
(CDR PAT)
LISTPCHK VALUETYPE]
[(MEMB (CAR PAT)
(QUOTE ($ ≠ --)))
(* The $ pattern is hard -- need to check several
cases -
if the pattern ends in a bunch of &'s , really need
to check length, even if LISTPCHK is NIL unless
LISTPCHK is NEVER)
(COND
((SETQ TMP (ISDOLLARN (CDR PAT)
VAR))
(OR NEVER TMP))
[(SINGLEPATLIST (CDR PAT))
(* If there is only a "SINGLE" at the end
(... $ ' a) then we can use last)
(* LAST is LISTP)
(MAKESUBST
(SETQ TMP (GENSYML VAR))
[SETQ TMP1 (MAKENLEFT VAR (LENGTH (CDR PAT]
([LAMBDA (FOO)
(COND
(YES (MAKEAND (MAKELISTP TMP1)
FOO))
(T FOO]
(MAKEMATCH
TMP
(CDR PAT)
(APPEND [MAPCAR (CDR PAT)
(FUNCTION (LAMBDA (X)
(QUOTE NEVER]
LISTPCHK)
VALUETYPE]
(T
(* Otherwise, do it as if there had to be a
(SOMETAIL X --) and let MAKESOME figure out when to
change it to a MEMB)
(MAKESOME VAR (SETQ TMP (GENSYML VAR))
(MAKEMATCH TMP (CDR PAT)
LISTPCHK
(QUOTE MATCH?]
[(EQ (CAAR PAT)
(QUOTE !))
(COND
((MEMB (CDAR PAT)
(QUOTE ($1 ≠1 &)))
(SETQ PAT (CONS $ (CDR PAT)))
(GO LP))
((AND (MEMB (CADAR PAT)
(QUOTE (= == ' PRED)))
(NOT (CDR PAT)))
(MAKETST (CADAR PAT)
(CADDAR PAT)
VAR))
(T (HELP "CANT DO ! YET"]
[(MEMB (CAAR PAT)
(QUOTE (←
SETQ)))
(COND
(MATCH (HELP
"I DON'T KNOW WHAT TO DO ABOUT VALUE TYPES")))
(COND
[(SINGLEPAT (CDDAR PAT))
(* I know how to do (← VAR &) where & is either &,
$1, = , ...,)
(MAKEAND (MAKEMATCH VAR (APPEND (CDDAR PAT)
(CDR PAT))
LISTPCHK VALUETYPE)
(MAKESETQ (CADAR PAT)
(MAKECAR VAR]
((AND [MEMBER (CDDAR PAT)
(QUOTE ((--)
($)
(≠]
(NOT (CDR PAT)))
(MAKESETQ (CADAR PAT)
VAR))
(T (HELP " TRYING TO SET VAR TO A SEGMENT ")
(* But if it's a segment
match, it's harder)
(MAKEAND (MAKEMATCH (MAKECAR VAR)
(CADDAR PAT)
LISTPCHK VALUETYPE)
(MAKESETQ (CADAR PAT)
(MAKECAR VAR))
(MAKEMATCH (CDR VAR)
(CDR PAT)
LISTPCHK VALUETYPE]
[(EQ (CAAR PAT)
(QUOTE ANY))
(COND
[(EVERY (CDAR PAT)
(FUNCTION SINGLEPAT))
(* Same for ANY's)
(MAKEOR (MAPCAR (CDAR PAT)
(FUNCTION (LAMBDA (PAT1)
(MAKEMATCH VAR
(CONS PAT1
(CDR PAT))
LISTPCHK VALUETYPE]
(T (HELP
"TRYING TO DO AN ANY WHERE SOME ARE NOT SINGLE PATS"]
(T
(* If not ← , SETQ, or ANY, it's just a sub-pattern
-- AND away)
(MAKEAND (MAKEMATCH (MAKECAR VAR)
(CAR PAT)
LISTPCHK VALUETYPE)
(MAKEMATCH (MAKECDR VAR)
(CDR PAT)
LISTPCHK VALUETYPE])
(PRINSET
[LAMBDA (VAR VAL)
(PRIN1 "SETTING " T)
(PRIN1 VAR)
(PRIN1 " TO " T)
(PRINT VAL T)
(SET VAR VAL])
(MATCH
[LAMBDA (VAR PAT)
(COND
((NOT PAT)
(NOT VAR))
([MEMBER PAT (QUOTE (($)
(--)
$1 & (≠]
T)
((NLISTP PAT)
(PRINSET PAT VAR))
[(NLISTP (CAR PAT))
(SELECTQ (CAR PAT)
[==(AND (EQ (CAR VAR)
(EVAL (CADR PAT)))
(MATCH (CDR VAR)
(CDDR PAT]
[=(AND (EQUAL (CAR VAR)
(EVAL (CADR PAT)))
(MATCH (CDR VAR)
(CDDR PAT]
[($ ≠ --)
(FOR NEW VAR2 ON VAR OR (MATCH VAR2 (CDR PAT]
((≠1 $1 &)
(MATCH (CDR VAR)
(CDR PAT)))
['(AND (APPLY* (COND
((ATOM (CADR PAT))
(QUOTE EQ))
(T (QUOTE EQUAL)))
(CADR PAT)
(CAR VAR))
(MATCH (CDR VAR)
(CDDR PAT]
(AND (PRINSET (CAR PAT)
(CAR VAR))
(MATCH (CDR VAR)
(CDR PAT]
[(MEMB (CAAR PAT)
SETFNS)
(COND
((MATCH (CAR VAR)
(CADDAR PAT))
(PRINSET (CADAR PAT)
(CAR VAR))
(MATCH (CDR VAR)
(CDR PAT]
(T (AND (MATCH (CAR VAR)
(CAR PAT))
(MATCH (CDR VAR)
(CDR PAT])
(MAKEREPLACE
[LAMBDA (FORM WITH)
(SETQ FORM (FULLEXPANSION FORM))
(SELECTQ (CAR FORM)
(CAR (LIST (QUOTE RPLACA)
(CADR FORM)
WITH))
[CDR (COND
((EQ (CAADR FORM)
(QUOTE LAST))
(LIST (QUOTE NCONC)
(CADADR FORM)
WITH))
(T (LIST (QUOTE RPLACD)
(CADR FORM)
WITH]
(HELP "HOW DO YOU REPLACE" FORM])
(FIXSELM
[LAMBDA (SELLIST)
(COND
((NULL (CDR SELLIST))
(LIST (CONS (QUOTE T)
SELLIST)))
(T (CONS (CONS (MAKEMATCH SELEXP (PARSE (CAAR SELLIST)))
(CDAR SELLIST))
(FIXSELM (CDR SELLIST])
(FOO
[LAMBDA (FOO)
(SELECTM FOO ((' A -- ' B -- ' C)
FOOBAZ)
((-- WHO ←
$1 ' C --)
FOOBAR)
(WHOHA])
(PACKSYM
[LAMBDA (VAR)
(PACK (LIST VAR (QUOTE !)
(SETQ GENSYMCNT (ADD1 GENSYMCNT])
)
(RPAQQ SETFNS (SETQ ←))
(RPAQQ VARDEFAULT ')
(RPAQQ LISTPCHK NEVER)
(RPAQ GENSYMCNT 0)
(DEFLIST(QUOTE(
[: (L ([LAMBDA (EXP PAT)
(COND ((EASYTORECOMPUTE EXP)
(MAKEMATCH EXP PAT))
(T (MAKEPROG (LIST (LIST (QUOTE MATCHEXP)
EXP))
(LIST (MAKEMATCH (QUOTE MATCHEXP)
PAT]
(CAR L)
(CAR (CDR L]
))(QUOTE MACRO))
STOP